home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGBLER / ASMCODE.LZH / FILE.PAS < prev    next >
Pascal/Delphi Source File  |  1984-07-21  |  19KB  |  552 lines
  1. {  $LIST+, $DEBUG+, $BRAVE+, $LINESIZE:132, $PAGESIZE:80, $OCODE+   }
  2. {  $ERRORS:50, $MATHCK+, $RANGECK+, $INITCK+, $INDEXCK+, $ENTRY+    }
  3. {  $LINE+, $RUNTIME+, $SYMTAB+, $WARN+, $GOTO-     }
  4. {  $TITLE:'FILE DATA BASE  ---  AEM$SCRATCH'             }
  5. {  $MESSAGE:'PASCAL - COMPILATION OPTIONS SET'     }
  6. {  $MESSAGE:'SYSTEM - COMPILATION BEGINS'          }
  7.  
  8. {$LIST-}
  9. {$INCLUDE:'A:FILKQQ.INC'}
  10. {$INCLUDE:'A:FILUQQ.INC'}
  11. {$LIST+}
  12. program file_code (input,output);  uses filkqq,filuqq;
  13.  
  14. const
  15.    maxname =   20;
  16.    maxstrg =   30;
  17.    blank   =   ' ';
  18.  
  19. type
  20.    stindex     =   byte;
  21.    idxrng      =   0..30;
  22.    varstrng    =   lstring(maxname);
  23.    fixstrng    =   string(maxname);
  24.    maxstrng    =   string(maxstrg);
  25.    maxlstrng   =   lstring(maxstrg);
  26.  
  27.    entrytype   =   record
  28.        name    :   record
  29.            lastname, firstname : fixstrng;
  30.            midinit : char
  31.        end;
  32.        addr    :   record
  33.            street  : maxstrng;
  34.            city    : fixstrng;
  35.            state   : string (2);
  36.            zip     : string(5)
  37.        end;
  38.        phone   :   record
  39.            number  : string(8);
  40.            areacod : string(3)
  41.        end;
  42.        dob : string(8)
  43.    end;
  44.  
  45.    nodeptr     =   ^node;
  46.    node    = record
  47.        entry :  entrytype;
  48.        next : nodeptr
  49.    end;
  50.  
  51. VAR [STATIC]
  52.    hol : nodeptr;
  53.    reccount : integer;
  54.    recfil : file of entrytype;
  55.    curtime, curdate : string(10);
  56.    option : char;
  57.    length : idxrng;
  58.    saved : boolean;
  59.  
  60. procedure recdisp (const curdisp : nodeptr; const reccount : integer); extern;
  61. procedure expand; extern;    {expand the cursor to a large block}
  62. procedure contract; extern;  {contract the cursor to normal scan line}
  63. procedure endxqq; extern;
  64. procedure getdata (var newrecord : entrytype);  extern;
  65. procedure view (const hol : nodeptr);  extern;
  66. procedure beep;external;
  67. procedure date (var s : string); extern;
  68. procedure time (var s : string); extern;
  69. procedure locate (row, column : integer); extern;
  70. procedure cls; extern;
  71. procedure keyboard (var temp : string; var length:idxrng; width:integer); extern;
  72.  
  73.  
  74. procedure browse (const hol : nodeptr; const reccount : integer);
  75.  
  76. var
  77.    option : char;
  78.    length : idxrng;
  79.    current : nodeptr;
  80.    count : integer;
  81.  
  82. label exit;
  83.  
  84. begin
  85.    count := 0;
  86.    time (curtime);   date (curdate);
  87.    current := hol;
  88.    while current <> nil do
  89.        begin
  90.            count := count + 1;
  91.            recdisp (current,reccount);
  92.            current := current^.next;    {get next record}
  93.            locate (20,1);  write (output, null : 60);
  94.            locate (22,1);  write (output, null : 60);
  95.            locate (23,1);   write (output, null : 60);
  96.            if current = nil then goto exit;
  97.            locate (23,1);   write (output, count : 1, ' of ', reccount : 1);
  98.            locate (23,70);  write (output, 'More...');
  99.            keyboard (option,length,1)
  100.        end;
  101. exit:
  102.    locate (23,1); write (output, null:78);
  103.    locate (23,1); write (output, 'End'); locate (23,70); write (output, 'EOF');
  104.    locate (24,1); write (output, null:78);
  105.    locate (24,1); write (output, 'Strike any key to return to primary options');
  106.    keyboard (option,length,1);
  107.  return
  108. end;  {procedure}
  109.  
  110. procedure  menu_display;
  111.    begin
  112.      cls;
  113.      locate (22, 1);
  114.      time (curtime);
  115.      write (output, 'Time: ', curtime, null:4, 'Date: ', curdate);
  116.      locate (2,26);
  117.      write (output, 'PRIMARY OPTIONS');
  118.      locate (4,5);       write (output, '<I>nsert NEW record');
  119.      locate (4,45);      write (output, '<D>elete OLD record');
  120.      locate (5,5);       write (output, '<U>pdate OLD record');
  121.      locate (5,45);      write (output, '<V>iew OLD record');
  122.      locate (6,5);       write (output, '<B>rowse current file');
  123.      locate (6,45);      write (output, '<F>ile with save');
  124.      locate (7,05);      write (output, '<A>bort without save');
  125.      locate (10,5);      write (output, 'OPTIONS (');
  126.      write (output, 'I');
  127.      if hol <> nil then write (output,'DUVBF') else write (output, blank,blank,blank,blank,blank);
  128.      write (output, 'A)');
  129.      write (output, '    --> ')
  130. end;
  131.  
  132.  
  133. procedure lookup (const key : entrytype;  var current,previous : nodeptr;
  134.                   const hol : nodeptr; var found : boolean)   [public];
  135.  
  136. var
  137.    notfound : boolean;   {true if next node must be examined}
  138. begin
  139.    previous := nil;    notfound := true;   current := hol;
  140.    found := false;
  141.    while notfound and (current <>  nil) do
  142.        with current^  do
  143.            if  key.name.lastname <= entry.name.lastname then
  144.                notfound := false
  145.            else  {move pointers to next node and look again}
  146.                begin
  147.                    previous := current;
  148.                    current := next
  149.                end;
  150.    if current <> nil then   {see if the name was found}
  151.    if key.name.lastname = current^.entry.name.lastname then
  152.                found := true
  153.        else found := false
  154. end;   {procedure listsearch}
  155.  
  156. procedure initialize (var hol : nodeptr;
  157.                       var reccount : integer);
  158.  
  159. var skipchar, fstat : char;
  160.     i : idxrng;
  161.     current, newnode, previous : nodeptr;
  162.   found : boolean;
  163.  
  164. begin
  165.    cls;
  166.      expand;
  167.    reccount := 0;
  168.    hol := nil;
  169.    locate (1,1);
  170.    time (curtime);
  171.    date (curdate);
  172.    write (output, 'Execution on:  ', curtime : 12, curdate);
  173.    locate (3,1);
  174.    write (output, 'Enter filename to update --> ');
  175.    readfn (input, recfil);
  176.    locate (5,1);
  177.    readln (input);
  178.    write ('Is this file new?  (Y/N) : ');
  179.    readln (input, fstat);
  180.    if (fstat = 'n') OR (fstat = 'N') THEN
  181.        begin
  182.                 recfil.trap := true;
  183.            reset (recfil);         {reset does performs an implied get operation}
  184.                 if recfil.errs <> 00 then    {file not found or disk error}
  185.                     begin
  186.                         writeln (output, 'File not on volume, or Disk error');
  187.                         contract;
  188.                         endxqq         {library terminate call}
  189.                     end;
  190.            writeln (output);
  191.            writeln (output, 'Existing file, opened');
  192.            writeln (output);
  193.            {$NILCK-}   {stop nil checking temporarily}
  194.            while not eof (recfil) do   {load the list with existing file}
  195.                begin
  196.                    new(newnode);
  197.                    newnode^.entry := recfil^;
  198.                    current := hol;   previous := nil;
  199.                    lookup (newnode^.entry,current,previous,hol,found);
  200.                    reccount := reccount + 1;
  201.                    get (recfil);
  202.                    if previous <> nil then
  203.                        begin
  204.                            newnode^.next := previous^.next;
  205.                            previous^.next := newnode
  206.                        end
  207.                    else
  208.                        begin
  209.                            newnode^.next := hol;
  210.                            hol := newnode
  211.                        end
  212.                end
  213.        end
  214.    else
  215.        begin
  216.            writeln (output);
  217.            writeln (output);
  218.            writeln (output, 'New file');
  219.            writeln (output, 'File will be created');
  220.            rewrite (recfil);
  221.            writeln (output, 'Created')
  222.        end;
  223.    locate (15,1);
  224.    write (output, 'Hit <ENTER> to continue...');
  225.    keyboard (skipchar, i, 1);
  226.    cls;
  227.    writeln (output)
  228.    {$NILCK+}    {restart nil reference checking}
  229. end;
  230.  
  231. procedure updrec (var hol : nodeptr; const reccount : integer);
  232.  
  233. var
  234.    tmpstrng : maxstrng;
  235.    temp : entrytype;
  236.    current, previous : nodeptr;
  237.    found : boolean;
  238.    select : char;
  239.    maxlen, length, i : idxrng;
  240.  
  241.    procedure chngstrng (var curstrng : string;  const newstrng : string; const length: idxrng; maxlen : idxrng);
  242.    var
  243.        j : idxrng;
  244.    begin
  245.        for j := 1 to length do
  246.            curstrng [j] := newstrng [j];
  247.        for j := length+1 to maxlen do
  248.        curstrng [j] := blank
  249.    end;  {procedure}
  250. begin {updrec}
  251.    current := hol;
  252.    cls;  time (curtime);
  253.    locate (1,1);
  254.    write (output, 'Page:  UPDATE', null : 4, 'Primary key cannot be modified');
  255.    locate (2,1); write (output, 'Time: ', curtime, null:3, 'Date: ', curdate);
  256.    locate (5,1); write (output, 'Enter LAST name to modify --> ');
  257.    locate (5,32); for i := 1 to 20 do write (output, '.');
  258.    locate (5,32); keyboard (temp.name.lastname, length, 20);
  259.    for i := length + 1 to 20 do
  260.        [   write (output, blank);
  261.            temp.name.lastname [i] := blank ];
  262.    locate (4,1);    write (output, '*Update Record: ', temp.name.lastname);
  263.    lookup (temp,current,previous,hol,found);
  264.    if found then
  265.        begin
  266.            recdisp (current, reccount);
  267.            with current^.entry do
  268.                begin
  269.                    locate (6,13);  keyboard (tmpstrng, length, 20);
  270.                    if length > 0 then   {change string}
  271.                        chngstrng (name.firstname, tmpstrng, length, 20);
  272.                    locate (6,56); keyboard (tmpstrng, length, 1);
  273.                    if length > 0 then
  274.                        chngstrng (name.midinit, tmpstrng, length, 1);
  275.                    locate (11,9); keyboard (tmpstrng, length, 30);
  276.                    if length > 0 then
  277.                        chngstrng (addr.street, tmpstrng, length, 30);
  278.                    locate (12, 7); keyboard (tmpstrng, length, 20);
  279.                    if length > 0 then
  280.                        chngstrng (addr.city, tmpstrng, length, 20);
  281.                    locate (12,48); keyboard (tmpstrng, length, 2);
  282.                    if length > 0 then
  283.                        chngstrng (addr.state, tmpstrng, length,2 );
  284.                    locate (12,66); keyboard (tmpstrng, length, 5);
  285.                    if length > 0 then
  286.                        chngstrng (addr.zip, tmpstrng, length, 5);
  287.                    locate (14,12); keyboard (tmpstrng, length, 3);
  288.                    if length > 0 then
  289.                        chngstrng (phone.areacod, tmpstrng, length, 3);
  290.                    locate (14,24); keyboard (tmpstrng, length, 8);
  291.                    if length > 0 then
  292.                        chngstrng (phone.number, tmpstrng, length, 8);
  293.                end;
  294.            locate (20,1 ); write (output, null : 60);
  295.            locate (22,1 ); write (output, null : 60);
  296.            locate (20,1 ); write (output, '*Modified.');
  297.            locate (22,1 ); write (output, 'Strike any key to return to primary options...');
  298.            keyboard (select, i, 1);
  299.            return      {to caller -- primary options}
  300.        end
  301.    else  {record requested is not found}
  302.        begin
  303.            cls;
  304.            locate (1,1); write (output, '*UPDATE');
  305.            locate (4,1); write (output, 'Search failure:');
  306.            locate (6,1); write (output, 'Record: ', temp.name.lastname, ' Not found -- Update not done');
  307.            locate (8,1); write (output, 'Strike any key to return to primary options...');
  308.            keyboard (select, i, 1);
  309.            return
  310.        end
  311. end;   {procedure}
  312.  
  313.  
  314. procedure insrec (var hol : nodeptr; var reccount : integer);
  315.  
  316. var
  317.    temp : entrytype;
  318.    newnode, current, previous : nodeptr;
  319.    found : boolean;
  320.    select : char;
  321.    i : idxrng;
  322.  
  323. begin
  324.    getdata (temp);
  325.    lookup (temp, current, previous, hol, found);
  326.    if not found then    {insert the record}
  327.        begin
  328.            reccount := reccount + 1;
  329.            new (newnode);
  330.            newnode^.entry := temp;
  331.            if previous <> nil then
  332.                begin
  333.                    newnode^.next := previous^.next;
  334.                    previous^.next := newnode
  335.                end
  336.            else    {node goes at the head of the list (hol)}
  337.                begin
  338.                    newnode^.next := hol;
  339.                    hol := newnode
  340.                end;
  341.            locate (23,1);
  342.            write ('*** NEW record, Saved: (# ',reccount:1,')  ', temp.name.lastname);
  343.            locate (24,1); write ('Strike any key to continue...');
  344.            keyboard (select, i, 1)
  345.        end
  346.    else   {this record already exists}
  347.        begin
  348.            cls;
  349.            locate (2,1);
  350.            write (output, '*** Unable to insert record:');
  351.            locate (4,1);
  352.            write (output, '*** ', temp.name.lastname, ' Already exists');
  353.            locate (5,1);
  354.            write (output, '*** DUPLICATE primary keys are not allowed');
  355.            locate (20,1);
  356.            write ('[U]pdate, or [R]eturn  --> ');
  357.            keyboard (select, i, 1);
  358.            if (select = 'U') or (select = 'u') then
  359.                updrec (hol,reccount)
  360.            else
  361.                return
  362.        end
  363. end;
  364.  
  365. procedure delrec (var hol : nodeptr;  var reccount : integer);
  366.  
  367. var
  368.    newnode, current, previous : nodeptr;
  369.    found : boolean;
  370.    select : char;
  371.    i, length : idxrng;
  372.    lnam : fixstrng;
  373.    temp : entrytype;
  374.  
  375.    procedure delrcrd (var hol : nodeptr);
  376.  
  377.    begin   {all the search variables are in a level above this, and visible}
  378.        if previous <> nil then
  379.            previous^.next := current^.next
  380.        else
  381.            hol := current^.next;
  382.        dispose (current);
  383.        reccount := reccount - 1
  384.    end;   {delrcrd}
  385. begin   {delrec}
  386.    cls;
  387.    if hol = nil then    {no records to save}
  388.        begin
  389.            locate (1,1);
  390.            write (output, 'Internal file contains NO records.');
  391.            locate (3,1);
  392.            write (output, 'No records to delete now.');
  393.            locate (7,1);
  394.            write (output, 'Strike any key to return to primary options');
  395.            keyboard (select,i,1);
  396.            return
  397.        end;
  398.    locate (1,1);
  399.    time (curtime);
  400.    write (output, 'Delete record:  ', curtime, null : 3, curdate);
  401.    locate (1,70);   write (output, 'DEL');
  402.    locate (2,1);
  403.    write (output, 'Page:  DEL:    <File unchanged>');
  404.    locate (5,1);
  405.    write (output, 'Enter LAST name of record to delete  --> ');
  406.    locate (5,42); for i := 1 to 20 do write (output, '.');
  407.    locate (5,42); keyboard (lnam, length, 20);
  408.    beep;  for i := length+1 to 20 do write (output, blank);
  409.    temp.name.lastname := lnam;
  410.    for i := length + 1 to 20 do   {pad out garbage from asm routine}
  411.        temp.name.lastname [i] := blank;
  412.    lookup (temp, current, previous, hol, found);
  413.    if not found then
  414.        begin
  415.            locate (8,1);
  416.            write (output, '*** Requested record not found  (');
  417.            for i := 1 to length do
  418.                write (output, lnam[i]);
  419.            write (output, ')');
  420.            locate (9,1);
  421.            write (output, '*** File unable to be modified');
  422.            locate (15,1);
  423.            write (output, 'Strike any key to return to primary options');
  424.            keyboard (select,i,1)
  425.        end
  426.    else   {record will be deleted}
  427.        begin
  428.            locate (8,1);
  429.            write (output, '*** Requested record located:');
  430.            locate (9,1);
  431.            write (output, '*** Delete?  --> ');
  432.            keyboard (select,length,1);
  433.            if (select = 'Y') or (select = 'y') then
  434.                delrcrd (hol)
  435.            else
  436.                begin
  437.                    locate (15,1);
  438.                    write (output, 'Record delete NOT confirmed');
  439.                    locate (17,1);
  440.                    write (output, 'Strike any key to return to primary options');
  441.                    keyboard (select,i,1);
  442.                    return
  443.                end
  444.        end
  445. end;   {procedure}
  446.  
  447. procedure filrec (const hol : nodeptr; const reccount : integer;
  448.                    var saved : boolean);
  449.  
  450. var
  451.    i : idxrng;
  452.    select : char;
  453.    current : nodeptr;
  454. begin
  455.    cls;
  456.    if hol = nil then    {no records to save}
  457.        begin
  458.            locate (1,1);
  459.            write (output, 'Internal file contains NO records.');
  460.            locate (3,1);
  461.            write (output, 'File remains unchanged.');
  462.            locate (7,1);
  463.            write (output, 'Strike any key to return to primary options');
  464.            keyboard (select,i,1);
  465.            return
  466.        end;
  467.    locate (1,1);
  468.    write (output, 'File records:',null:10, reccount : 1, ' Records to be saved');
  469.    locate (1,70);
  470.    write (output, 'FILE');
  471.    locate (2,1);
  472.    write (output, 'PAGE: SAVE', null : 10, 'Permanent File Modification');
  473.    locate (3,1);
  474.    time (curtime);
  475.    write (output, 'File will be rewritten', '   Time: ', curtime, null : 4, 'Date: ', curdate);
  476.    locate (10,1);
  477.    write (output, 'Writing ', reccount : 1, ' record(s) on file');
  478.    locate (12,1);
  479.    write (output, 'Writing ', sizeof(hol^.entry) * wrd(reccount) : 1 : 16,
  480.           'H bytes ', '(',sizeof(hol^.entry) * wrd(reccount): 1, ')');
  481.    rewrite (recfil);
  482.    current := hol;
  483.    while current <> nil do
  484.        begin
  485.            recfil^ := current^.entry;
  486.            put (recfil);
  487.            current := current^.next
  488.        end;
  489.    locate (15,1);
  490.    close (recfil);
  491.    reset (recfil);
  492.    write (output, 'Completed');
  493.    locate (20,1); write (output, 'Strike any key to return to primary options');
  494.    keyboard (select,i,1);
  495.    saved := true
  496. end;  {procedure}
  497.  
  498.  
  499. begin   {main}
  500.    date (curdate);
  501.    time (curtime);
  502.    cls;
  503.    saved := false;
  504.    initialize (hol, reccount);
  505.    menu_display;
  506.    keyboard (option,length,1);
  507.    while not (option in ['A','a']) do
  508.        begin
  509.            case option of
  510.            'I','i' :   insrec (hol, reccount);
  511.            'D','d' :   delrec (hol, reccount);
  512.            'F','f' :   filrec (hol, reccount,saved);
  513.            'U','u' :   updrec (hol, reccount);
  514.            'V','v' :   view (hol);
  515.            'B','b' :   browse (hol,reccount);
  516.            otherwise beep
  517.            end;   {case}
  518.            menu_display;
  519.            keyboard (option,length,1)
  520.        end;
  521.    cls;
  522.    if not saved and (hol <> nil) then   {file modified, not saved}
  523.        begin
  524.            locate (1,1);
  525.            write (output, 'Record file has not been saved.');
  526.            locate (3,1);
  527.            write (output, 'Internal file contains: ', sizeof(hol^.entry) * wrd(reccount) : 1, null:3,
  528.                   '(',sizeof(hol^.entry) * wrd(reccount):1:16,'H) bytes');
  529.            locate (5,1);  write (output, 'Continue ABORT sequence, with no save?  ');
  530.            keyboard (option,length,1);
  531.            if not (option in ['Y','y']) then
  532.                    begin
  533.                        locate (7,1); write (output, 'File will be saved');
  534.                        filrec (hol, reccount, saved)
  535.                    end
  536.            else
  537.                begin
  538.                    locate (7,1); write (output, 'Abort confirmed.');
  539.                    locate (8,1); write (output, 'Input file unchanged.')
  540.                end
  541.        end;   {if not saved}
  542.    writeln (output);
  543.    writeln (output);
  544.    locate (20,1); write (output, null : 60);
  545.    locate (20,1); write (output, 'Returning to DOS');
  546.    writeln (output);
  547.    writeln (output,' EOJ :');
  548.    time (curtime);
  549.      contract;
  550.    locate (23,1);  write (output, 'Execution terminated normally on ', curdate, null:2, curtime)
  551. end.
  552.